home *** CD-ROM | disk | FTP | other *** search
/ Aminet 28 / Aminet 28 (1998)(GTI - Schatztruhe)[!][Dec 1998].iso / Aminet / dev / basic / ace_final.lha / ACE_GPL_Release / prgs / Fractals / land.b < prev    next >
Encoding:
Text File  |  1996-08-29  |  3.2 KB  |  176 lines
  1. { Fractal Landscapes }
  2.  
  3. const parts=34,partsplus2=36
  4. const xscreen=640,yscreen=200
  5.     
  6. longint initial,picsize
  7. single    mini,maxi,depth,lt,rt,top,bottom
  8. dim     value&(parts,partsplus2)
  9.  
  10. sub rndchoice&(a,b)
  11. shared picsize,initial,mini,maxi
  12.   zw = (a+b) / 2 + rnd mod picsize - initial
  13.   if zw < mini then mini = zw
  14.   if zw > maxi then maxi = zw
  15.   rndchoice& = zw
  16. end sub
  17.  
  18. sub full
  19. shared initial,picsize,value&
  20. longint xko,yko
  21.   yko = 0
  22.   repeat 
  23.     xko = initial
  24.     repeat
  25.       value&(xko,yko)=rndchoice&(value&(xko-initial,yko),value&(xko+initial,yk0))
  26.       value&(yko,yko)=rndchoice&(value&(yko,xko-initial),value&(yko,xko+initial))
  27.       a = value&(xko-initial,parts-xko-yko+initial)
  28.       b = value&(xko+initial,parts-xko-yko-initial)
  29.       value&(xko,parts-xko-yko)=rndchoice&(a,b)
  30.       xko = xko + picsize
  31.     until xko > (parts - yko)
  32.     yko = yko + picsize
  33.   until yko >= parts 
  34. end sub
  35.  
  36. sub fill
  37. shared mini,maxi,value&,picsize,initial
  38. longint i,j
  39.   for i=0 to parts
  40.     for j=0 to partsplus2
  41.       value&(i,j) = 0
  42.     next
  43.   next
  44.  
  45.   mini=0 : maxi=0
  46.   picsize = parts
  47.   initial = picsize \ 2
  48.  
  49.   repeat
  50.     full
  51.     picsize = initial
  52.     initial = initial \ 2
  53.   until initial = picsize
  54.  
  55.   value&(0,parts+1) = mini
  56.   value&(1,parts+1) = maxi
  57.   value&(2,parts+1) = picsize
  58.   value&(3,parts+1) = initial
  59. end sub
  60.  
  61. sub set_universal_point(xw,yw)
  62. shared lt,rt,top,bottom
  63.   xs = ((xw-lt) * xscreen / (rt-lt)) 
  64.   ys = (yw-bottom) * yscreen / (top-bottom)
  65.   pset (xs,ys) 
  66. end sub
  67.  
  68. sub draw_universal_line(xw,yw)
  69. shared lt,rt,top,bottom
  70.   xs = ((xw-lt) * xscreen / (rt-lt)) 
  71.   ys = (yw-bottom) * yscreen / (top-bottom)
  72.   line step (xs,ys) 
  73. end sub
  74.  
  75. sub universal_x&(xw)
  76. shared lt,rt
  77.   universal_x& = ((xw-lt) * xscreen / (rt-lt)) 
  78. end sub
  79.  
  80. sub universal_y&(yw)
  81. shared top,bottom
  82.   universal_y& = (yw-bottom) * yscreen / (top-bottom)
  83. end sub
  84.  
  85. on mouse gosub finish
  86. mouse on
  87.  
  88. sub slant(yko)
  89. shared value&,depth
  90. longint xko
  91.  
  92.   setxy universal_x&(yko),universal_y&(yko+value&(0,yko)*depth)
  93.  
  94.   for xko=0 to parts-yko
  95.     draw_universal_line(xko+yko,yko+value&(xko,yko)*depth)
  96.   next
  97.  
  98.  { for xko=parts-yko to parts
  99.     draw_universal_line(xko+yko,yko+value&(parts-yko,parts-xko)*depth)
  100.   next    }  
  101. end sub
  102.  
  103. sub along(xko)
  104. shared value&,depth
  105. longint yko
  106.  
  107.   setxy universal_x&(xko),universal_y&(value&(xko,0)*depth)
  108.  
  109.   for yko = 0 to parts-xko
  110.     draw_universal_line(xko+yko,yko+value&(xko,yko)*depth)
  111.   next
  112.  
  113. {  for yko = parts-xko to parts
  114.     draw_universal_line(xko+yko,xko+value&(parts-yko,parts-xko)*depth)
  115.   next}
  116. end sub
  117.     
  118. sub draw
  119. shared depth,value&
  120. longint xko,yko
  121.  
  122.   for yko = 0 to parts
  123.     slant(yko)
  124.   next
  125.  
  126.   for xko = 0 to parts
  127.     along(xko)
  128.   next
  129. end sub
  130.  
  131. mouse off
  132.  
  133. sub initialise
  134. shared lt,rt,top,bottom,depth
  135. { input "left   (try  0)   : ",lt
  136.  input "right  (try 15)   : ",rt
  137.  input "bottom (try 15)   : ",bottom
  138.  input "top    (try  0)   : ",top
  139.  input "depth  (try  0.05): ",depth }
  140.  
  141.  '..demo parameters
  142.  lt = 0
  143.  rt = 20
  144.  bottom = 10
  145.  top = 0
  146.  depth = 0.15
  147. end sub
  148.  
  149. sub compute_and_display
  150.   fill
  151.   draw
  152. end sub
  153.      
  154. { ** main ** }
  155. initialise
  156.  
  157. screen 1,xscreen,yscreen,2,2
  158.  
  159. palette 0,0,0,0
  160. palette 1,1,1,1
  161.  
  162. color 1
  163.  
  164. penup
  165. randomize timer
  166. compute_and_display
  167.  
  168. finish:
  169.  locate 3,5
  170.  prints "hit a key..."
  171.  while inkey$="":Sleep:wend
  172.  
  173.  screen close 1
  174.  
  175.  STOP  
  176.